home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 2003 August / MW 8 2003 CD1.iso / Inside Macworld / Product News / gimp-1.2.4.sit / gimp-1.2.4 / plug-ins / perl / Perl-Server < prev    next >
Encoding:
Text File  |  2000-08-27  |  12.1 KB  |  341 lines
  1. #!/usr/bin/perl
  2.  
  3. # you can enable unix sockets, tcp sockets, or both (or neither...)
  4. #
  5. # enabling tcp sockets can be a security risk. If you don't understand why,
  6. # you shouldn't enable it!
  7. #
  8. $use_unix    = 1;
  9. $use_tcp    = 1;    # tcp is enabled only when authorization is available
  10.  
  11. use Socket;
  12.  
  13. use strict;
  14. use vars qw($use_unix $use_tcp $trace_res $server_quit $max_pkt $unix $tcp $ps_flags
  15.             $auth @authorized $exclusive $rm $saved_rm %stats);
  16. use Gimp qw(__ N_);
  17. use Gimp::Net ();
  18.  
  19. N_"/Xtns/Perl"; # workaround for i18n weirdnesses
  20.  
  21. Gimp::set_trace(\$trace_res);
  22. Gimp::ignore_functions(qw(gimp_progress_init gimp_progress_update));
  23.  
  24. #
  25. # the protocol is quite easy ;)
  26. # at connect() time the server returns
  27. # PERL-SERVER protocolversion [AUTH]
  28. #
  29. # length_of_packet cmd
  30. #
  31. # cmd            response        description
  32. # AUTH password        ok [message]        authorize yourself
  33. # QUIT                        quit server
  34. # EXEC in-args        status out-args        run simple command
  35. # TRCE trace in-args    trace status out-args    run simple command (with tracing)
  36. # TEST procname        bool            check for procedure existance
  37. # DTRY in-args                    destroy all argument objects
  38. # LOCK lock? shared?                lock or unlock
  39. # RSET                        reset server (NYI)
  40. #
  41. # args is "number of arguments" arguments preceded by length
  42. # type is first character
  43. # Sscalar-value
  44. # Aelem1\0elem2...
  45. # Rclass\0scalar-value
  46. #
  47.  
  48. $server_quit = 0;
  49.  
  50. my $max_pkt = 1024*1024*8;
  51. my $exclusive = 0;
  52.  
  53. sub slog {
  54.   return if $ps_flags & &Gimp::_PS_FLAG_QUIET;
  55.   print time(),": ",@_,"\n";
  56. }
  57.  
  58. sub destroy_objects {
  59.    Gimp::Net::destroy_objects(@_);
  60. }
  61.  
  62. # this is hardcoded into handle_request!
  63. sub reply {
  64.    my $fh=shift;
  65.    my $data=Gimp::Net::args2net(0,@_);
  66.    print $fh pack("N",length($data)).$data;
  67. }
  68.  
  69. sub handle_request($) {
  70.    my($fh)=@_;
  71.    my($length,$req,$data,@args,$trace_level);
  72.    
  73.    eval {
  74.       local $SIG{ALRM}=sub { die "1\n" };
  75.       #alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
  76.       read($fh,$length,4) == 4 or die "2\n";
  77.       $length=unpack("N",$length);
  78.       $length>0 && $length<$max_pkt or die "3\n";
  79.       #alarm(6) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
  80.       read($fh,$req,4) == 4 or die "4\n";
  81.       #alarm(20) unless $ps_flags & &Gimp::_PS_FLAG_BATCH;
  82.       read($fh,$data,$length-4) == $length-4 or die "5\n";
  83.       #alarm(0);
  84.    };
  85.    return 0 if $@;
  86.    
  87.    if(!$auth or $authorized[fileno($fh)]) {
  88.       if($req eq "EXEC") {
  89.          no strict 'refs';
  90.          ($req,@args)=Gimp::Net::net2args(1,$data);
  91.          @args=eval { Gimp->$req(@args) };
  92.          $data=Gimp::Net::args2net(1,$@,@args);
  93.          print $fh pack("N",length($data)).$data;
  94.       } elsif ($req eq "TEST") {
  95.          no strict 'refs';
  96.          print $fh (defined(*{"Gimp::Lib::$data"}{CODE}) || Gimp::_gimp_procedure_available($data)) ? "1" : "0";
  97.       } elsif ($req eq "DTRY") {
  98.          Gimp::Net::destroy_objects Gimp::Net::net2args 0,$data;
  99.          print $fh pack("N",0); # fix to work around using non-sysread/write functions
  100.       } elsif($req eq "TRCE") {
  101.          no strict 'refs';
  102.          ($trace_level,$req,@args)=Gimp::Net::net2args 1,$data;
  103.          Gimp::set_trace($trace_level);
  104.          $trace_res="";
  105.          @args=eval { Gimp->$req(@args) };
  106.          $data=Gimp::Net::args2net(1,$trace_res,$@,@args);
  107.          print $fh pack("N",length($data)).$data;
  108.          Gimp::set_trace(0);
  109.       } elsif ($req eq "QUIT") {
  110.          slog __"received QUIT request";
  111.          $server_quit = 1;
  112.       } elsif($req eq "AUTH") {
  113.          $data=Gimp::Net::args2net(0,1,__"authorization unnecessary");
  114.          print $fh pack("N",length($data)).$data;
  115.       } elsif($req eq "LOCK") {
  116.          my($lock,$shared)=unpack("N*",$data);
  117.          slog __"WARNING: shared locking requested but not implemented" if $shared;
  118.          if($lock) {
  119.             unless($exclusive) {
  120.                $saved_rm=$rm;
  121.                undef $rm; vec($rm,fileno($fh),1)=1;
  122.             }
  123.             $exclusive++;
  124.          } else {
  125.             if ($exclusive) {
  126.                $exclusive--;
  127.                $rm = $saved_rm unless $exclusive;
  128.             } else {
  129.                slog __"WARNING: client tried to unlock without holding a lock";
  130.             }
  131.          }
  132.       } else {
  133.          print $fh pack("N",0);
  134.          slog __"illegal command received, aborting connection";
  135.          return 0;
  136.       }
  137.    } else {
  138.       if($req eq "AUTH") {
  139.          my($ok,$msg);
  140.          if($data eq $auth) {
  141.             $ok=1;
  142.             $authorized[fileno($fh)]=1;
  143.          } else {
  144.             $ok=0;
  145.             $msg=__"wrong authorization, aborting connection";
  146.             slog $msg;
  147.             sleep 5; # safety measure
  148.          }
  149.          $data=Gimp::Net::args2net(0,$ok,$msg);
  150.          print $fh pack("N",length($data)).$data;
  151.          return $ok;
  152.       } else {
  153.          print $fh pack("N",0);
  154.          slog __"unauthorized command received, aborting connection";
  155.          return 0;
  156.       }
  157.    }
  158.    return 1;
  159. }
  160.  
  161. sub extension_perl_server {
  162.   my $run_mode=$_[0];
  163.   $ps_flags=$_[1];
  164.   my $extra=$_[2];
  165.   
  166.   if ($run_mode == &Gimp::RUN_NONINTERACTIVE) {
  167.      if ($ps_flags & &Gimp::_PS_FLAG_BATCH) {
  168.         my($fh) = local *FH;
  169.         open $fh,"+<&$extra" or die __"unable to open Gimp::Net communications socket: $!\n";
  170.         select $fh; $|=1; select STDOUT;
  171.         reply $fh,"PERL-SERVER",$Gimp::_PROT_VERSION;
  172.         while(!$server_quit and !eof($fh)) {
  173.            last unless handle_request($fh);
  174.         }
  175. #        Gimp::gimp_quit(0);    # borken in libgimp #d#FIXME#
  176.         kill 'KILL',getppid();    # borken do not do this.. #d#FIXME#
  177.         exit(0);
  178. #        close $fh;
  179.         return;
  180.      }
  181.   } else {
  182.      $run_mode=&Gimp::RUN_INTERACTIVE;
  183.      $ps_flags=0;
  184.   }
  185.   
  186.   my $host = $ENV{'GIMP_HOST'};
  187.   $auth = $host=~s/^(.*)\@// ? $1 : undef;    # get authorization
  188.   
  189.   slog __"server version $Gimp::VERSION started".($auth ? __", authorization required" : "");
  190.   
  191.   $SIG{PIPE}='IGNORE'; # may not work, since libgimp (eech) overwrites it.        
  192.   my($unix_path)=$Gimp::Net::default_unix_dir.$Gimp::Net::default_unix_sock;
  193.   my(%handles,$r,$fh,$f);
  194.   
  195.   if ($host ne "") {
  196.      if ($host=~s{^spawn/}{}) {
  197.         die __"invalid GIMP_HOST: 'spawn' is not a valid connection method for the server";
  198.      } elsif ($host=~s{^unix/}{/}) {
  199.         $unix = local *FH;
  200.         socket($unix,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
  201.           && bind($unix,sockaddr_un $host)
  202.           && listen($unix,5)
  203.             or die __"unable to create listening unix socket: $!\n";
  204.         slog __"accepting connections in $host";
  205.         vec($rm,fileno($unix),1)=1;
  206.      } else {
  207.         $host=~s{^tcp/}{};
  208.         my($host,$port)=split /:/,$host;
  209.         $port=$Gimp::Net::default_tcp_port unless $port;
  210.         $tcp = local *FH;
  211.         socket($tcp,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
  212.            && setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
  213.            && bind($tcp,sockaddr_in $port,INADDR_ANY)
  214.            && listen($tcp,5)
  215.              or die __"unable to create listening tcp socket: $!\n";
  216.         slog __"accepting connections on port $port";
  217.         vec($rm,fileno($tcp),1)=1;
  218.      }
  219.   } else {
  220.      if ($use_unix) {
  221.         unlink $unix_path;
  222.         rmdir $Gimp::Net::default_unix_dir;
  223.         mkdir $Gimp::Net::default_unix_dir,0700 or die "$!";
  224.         $unix = local *FH;
  225.         socket($unix,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
  226.            && bind($unix,sockaddr_un $unix_path)
  227.            && listen($unix,5)
  228.              or die __"unable to create listening unix socket: $!\n";
  229.         slog __"accepting connections on $unix_path";
  230.         vec($rm,fileno($unix),1)=1;
  231.      }
  232.      if ($use_tcp && $auth) {
  233.         $tcp = local *FH;
  234.         socket($tcp,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
  235.            && setsockopt($tcp,SOL_SOCKET,SO_REUSEADDR,1)
  236.            && bind($tcp,sockaddr_in $Gimp::Net::default_tcp_port,INADDR_ANY)
  237.            && listen($tcp,5)
  238.              or die __"unable to create listening tcp socket: $!\n";
  239.         slog __"accepting connections on port $Gimp::Net::default_tcp_port";
  240.         vec($rm,fileno($tcp),1)=1;
  241.     }
  242.   }
  243.   
  244.   !$tcp || $auth or die __"authorization required for tcp connections";
  245.   
  246.   sub new_connection {
  247.      my $fh = shift;
  248.      select $fh; $|=1; select STDOUT;
  249.      $handles{fileno($fh)}=$fh;
  250.      my @r = ("PERL-SERVER",$Gimp::_PROT_VERSION);
  251.      push(@r,"AUTH") if $auth;
  252.      reply $fh,@r;
  253.      vec($rm,fileno($fh),1)=1;
  254.      $stats{fileno($fh)}=[0,time];
  255.   }
  256.  
  257.   while(!$server_quit) {
  258.     if(select($r=$rm,undef,undef,undef)>0) {
  259.       if ($tcp && vec($r,fileno($tcp),1)) {
  260.         my $h = local *FH;
  261.         my ($port,$host) = sockaddr_in (accept ($h,$tcp)) or die __"unable to accept tcp connection: $!\n";
  262.         new_connection($h);
  263.         slog __"accepted tcp connection from ",inet_ntoa($host),":$port";
  264.       }
  265.       if ($unix && vec($r,fileno($unix),1)) {
  266.         my $h = local *FH;
  267.         accept ($h,$unix) or die __"unable to accept unix connection: $!\n";
  268.         new_connection($h);
  269.         slog __"accepted unix connection";
  270.       }
  271.       for $f (keys(%handles)) {
  272.         if(vec($r,$f,1)) {
  273.           $fh=$handles{$f};
  274.           if(handle_request($fh)) {
  275.             $stats{$f}[0]++;
  276.           } else {
  277.             slog sprintf __"closing connection %d (%d requests in %g seconds)", $f, $stats{$f}[0], time-$stats{$f}[1];
  278.             if ($exclusive) {
  279.                $rm = $saved_rm;
  280.                $exclusive = 0;
  281.                slog __"WARNING: client disconnected while holding an active lock\n";
  282.             }
  283.             vec($rm,$f,1)=0;
  284.             delete $handles{$f};
  285.             undef $fh;
  286.           }
  287.           last; # this is because the client might have called lock()
  288.         }
  289.       }
  290.     }
  291.   }
  292.   
  293.   slog __"server going down...";
  294.   if ($use_tcp) {
  295.     undef $tcp;
  296.   }
  297.   if ($use_unix) {
  298.     undef $unix;
  299.     unlink $unix_path;
  300.     rmdir $Gimp::Net::default_unix_dir;
  301.   }
  302. }
  303.  
  304. Gimp::register_callback extension_perl_server => \&extension_perl_server;
  305.  
  306. Gimp::on_query {
  307.    Gimp->install_procedure("extension_perl_server", "Start the Gimp-Perl Server",
  308.                            "This is the server for plug-ins written using the Gimp::Net module",
  309.                            "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-12-02",
  310.                            N_"<Toolbox>/Xtns/Perl/Server", undef, &Gimp::EXTENSION,
  311.                            [
  312.                             [&Gimp::PDB_INT32, "run_mode", "Interactive, [non-interactive]"],
  313.                             [&Gimp::PDB_INT32, "flags", "internal flags (must be 0)"],
  314.                             [&Gimp::PDB_INT32, "extra", "multi-purpose ;)"],
  315.                            ],[]);
  316.  
  317.    Gimp->install_procedure("gimp_procedural_db_constant_register", "Register a plug-in specific integer constant",
  318.                            "Plug-ins should register their custom constants using this function, so".
  319.                            "other plug-ins (notably script-languages) can access these using symbolic names",
  320.                            "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-07-07",
  321.                            undef, undef, &Gimp::EXTENSION,
  322.                            [
  323.                             [&Gimp::PDB_STRING, "procedure", "The name of the function that uses this constant"],
  324.                             [&Gimp::PDB_STRING, "arg_num", "The name of the argument that this constant is used for"],
  325.                             [&Gimp::PDB_STRING, "constant_name", "The name of the constant, should be all-uppercase"],
  326.                             [&Gimp::PDB_INT32,  "constant_value", "The (integer) value for this constant"],
  327.                            ],[]);
  328.    Gimp->install_procedure("gimp_procedural_db_set_default", "Set the default value for a plug-in argument",
  329.                            "Plug-ins should register default values for their arguments",
  330.                            "Marc Lehmann <pcg\@goof.com>", "Marc Lehmann", "1999-07-07",
  331.                            undef, undef, &Gimp::EXTENSION,
  332.                            [
  333.                             [&Gimp::PDB_STRING, "procedure", "The name of the function that uses this constant"],
  334.                             [&Gimp::PDB_STRING, "arg_num", "The name of the argument that this constant is used for"],
  335.                             [&Gimp::PDB_INT32,  "default_value", "The default value for this constant"],
  336.                            ],[]);
  337. };
  338.  
  339. exit Gimp::main;
  340.  
  341.